home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga Tools 2
/
Amiga Tools 2.iso
/
tools
/
jade
/
lisp
/
keymap.jl
< prev
next >
Wrap
Lisp/Scheme
|
1995-03-09
|
5KB
|
144 lines
;;;; keymap.jl -- extra functions for handling keymaps
;;; Copyright (C) 1994 John Harper <jsh@ukc.ac.uk>
;;; This file is part of Jade.
;;; Jade is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2, or (at your option)
;;; any later version.
;;; Jade is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;; You should have received a copy of the GNU General Public License
;;; along with Jade; see the file COPYING. If not, write to
;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(provide 'keymap)
;;;###autoload
(defun print-keymap (&optional keymap-list buffer)
"Prints a description of the installed keymaps in the current buffer."
(unless keymap-list
(setq keymap-list keymap-path))
(unless buffer
(setq buffer (current-buffer)))
(insert "\nKey/Event")
(indent-to 24)
(insert "Binding\n---------")
(indent-to 24)
(insert "-------\n\n")
(let
(done-list) ; keymaps already printed
(while keymap-list
(let
((keymap (car keymap-list))
km-prefix-string)
(setq keymap-list (cdr keymap-list))
(when (and (not (keymapp keymap)) (consp keymap))
(setq km-prefix-string (cdr keymap)
keymap (car keymap)))
(unless (memq keymap done-list)
(setq done-list (cons keymap done-list))
(when (symbolp keymap)
(format (current-buffer) " -- %s:\n" keymap)
(setq keymap (with-buffer buffer (symbol-value keymap))))
(when (keymapp keymap)
(cond
((vectorp keymap)
(let
((i (length keymap)))
(while (>= i 0)
(km-print-list (aref keymap i))
(setq i (1- i)))))
(t
(km-print-list (cdr keymap)))))
(insert "\n"))))))
;; Print one keymap. This accesses the free variables `keymap-list' and
;; `km-prefix-string' -- both in describe-keymap.
(defun km-print-list (keymap)
(let
(key cmd event-str)
(while keymap
(setq key (car keymap)
cmd (aref key 2)
event-str (event-name (cons (aref key 0) (aref key 1))))
(when (and (eq (car cmd) 'setq) (eq (nth 1 cmd) 'next-keymap-path))
;; Link to another keymap; add it to the list of keymaps to
;; examine later.
(let*
((new-str (concat km-prefix-string (if km-prefix-string ?\ )
event-str))
(new-list (mapcar #'(lambda (km)
(cons km new-str))
(eval (nth 2 cmd)))))
(setq keymap-list (append keymap-list new-list))))
(insert (concat km-prefix-string (if km-prefix-string ?\ ) event-str))
(indent-to 24)
(prin1 cmd (current-buffer))
(insert "\n")
(setq keymap (cdr keymap)))))
;; Get one event
(defun km-read-event-fun ()
(throw 'read-event (current-event)))
;;;###autoload
(defun read-event (&optional title)
"Read the next event and return a cons cell containing the two integers that
define that event."
(let
((buffer (current-buffer))
(old-kp keymap-path)
(old-nkp next-keymap-path))
(setq keymap-path nil
next-keymap-path nil
status-line-cursor t)
(add-hook 'unbound-key-hook 'km-read-event-fun)
(unwind-protect
(catch 'read-event
(message (or title "Type a key:"))
(recursive-edit))
(with-buffer buffer
(remove-hook 'unbound-key-hook 'km-read-event-fun)
(setq keymap-path old-kp
next-keymap-path old-nkp
status-line-cursor nil)))))
;;;###autoload
(defun describe-key ()
"Read an event sequence from the user then display details of the command it
would invoke."
(interactive)
(let
(names event command done)
(while (not done)
(setq event (read-event (concat "Enter a key sequence: " names))
names (concat names (if names ?\ )
(event-name event)))
(if (setq command (lookup-event-binding event t))
(if (and (eq (car command) 'setq)
(eq (nth 1 command) 'next-keymap-path))
;; A link to another keymap
(call-command command)
;; End of the chain
(require 'help)
(help-setup)
(format (current-buffer) "\n%s -> %S\n" names command)
(when (functionp command)
(format (current-buffer)
"\n%s\n"
(or (documentation command) "")))
(goto-buffer-start)
(setq done t))
(message (concat names " is unbound. "))
(setq done t
next-keymap-path nil)))))